#!/usr/bin/perl -wc

# References in this document are to RFC 2821 unless otherwise
# specified.


package RFCMail::ESMTP::Server;

use strict;
use base qw(RFCMail::Common::Layered);
use RFCMail::Common::Grammar qw(gen_id);


sub import {
    my $class = shift;
    $class->SUPER::import('RFCMail::ESMTP::Common', @_);
}


sub data_start {
    my $self = shift;
    $self->{state}->{trans_id} = gen_id();
    return ($self->SUPER::data_start(@_));
}


sub data_abort {
    my $self = shift;
    $self->SUPER::data_abort(@_);
    delete($self->{state}->{trans_id});
}


sub data_commit {
    my $self = shift;
    $self->SUPER::data_commit(@_);
    # buffers cleared in accordance with section 4.1.1.4
    $self->reset;
}



package RFCMail::ESMTP::Server::base;

use strict;
use IO::Handle;
use IO::Socket::INET;
use RFCMail::Util::NetEnd;
use RFCMail::Common::Grammar qw(gen_date_time);
use RFCMail::ESMTP::Grammar::Base qw(MAILBOX_RE);
use RFCMail::ESMTP::Grammar::Generator qw(encode_extended_domain);
use RFCMail::ESMTP::Grammar::Parser qw(decode_string);
use RFCMail::ESMTP::Object::ReversePath qw(ReversePath);
use RFCMail::ESMTP::Object::ForwardPath qw(ForwardPath);
use RFCMail::ESMTP::Object::Parameters qw(Parameters);
use RFCMail::ESMTP::Object::Mailbox qw(Mailbox);


sub init {
    my $self = shift;
    $self->{timeout} = 300
	if not defined($self->{timeout});
    $self->{state} = RFCMail::ESMTP::Server::state->new
        if not defined($self->{state});
    $self->{handlers} = RFCMail::ESMTP::Server::parser->new_standard
	if not defined($self->{handlers});
    $self->{greeting} = "ESMTP Server ready for ".$self->peer_address_literal("non-inet session")
        if not defined($self->{greeting});
}


sub session {
    my ($self) = @_;
    my ($rcode, $mode_method);
    my $peer = $self->peer_address_literal("non-inet client");
    $self->logmsg(n => "commencing session with $peer");
    $self->{mode} = 'command_mode';
    my ($connect) = $self->{handlers}->parse_cmd("_");
    $rcode = $self->reply($self->$connect);
    while ($rcode !~ /^.21/) {
	$mode_method = $self->{mode};
	$rcode = $self->$mode_method;
    }
    $self->logmsg(n => "session with $peer ends");
    return ($rcode);
}


sub command_mode {
    my ($self) = @_;
    my ($line) = $self->get_line($self->{timeout});
    if (not defined($line)) {
	$self->logmsg(i => "client closed connection: performing implicit quit");
	return (621);
    }
    return ($self->reply($self->command($line)));
}


sub data_mode {
    my ($self) = @_;
    my $line;
    while (1) {
	$line = $self->get_line($self->{timeout});
	if (not defined($line)) {
	    # End-of-file encountered
	    $self->logmsg(n => "client closed connection during DATA phase");
	    return (621);
	}
	if ($line eq '.') {
	    # End-of-data marker encountered
	    $self->{mode} = 'command_mode';
	    my $reply = $self->data_finish;
	    if ($reply->[0] == 250) {
		$self->data_commit;
	    }
	    else {
		$self->data_abort;
	    }
	    return ($self->reply($reply));
	}
	# An ordinary data line -- perform dot-unstuffing if needs be
	substr $line, 0, 1, ""
	    if $line =~ /^\./;
	$self->data_line($line);
	$self->{state}->{data_lines}++;
    }
}


sub command {
    my ($self, $line) = @_;
    my $reply;
    if (defined($self->{halt})) {
	$reply = [421, split(/\n+/, $self->{halt})];
    }
    elsif ($line =~ /[\200-\377]/) {
	$reply = [500, "Syntax error: illegal characters in data"];
    }
    else {
	my ($method, @parms) = $self->{handlers}->parse_line($line);
	$reply = $self->$method(@parms);
    }
    return ($reply);
}


sub connect_handler {
    my ($self) = @_;
    return ([220, split(/\n+/, $self->{greeting})]);
}


sub ehlo_handler {
    my ($self, $cmd, $domain) = @_;
    $self->reset;
    $self->{state}->{Greeting} = $domain;
    $self->{state}->{Protocol} = $cmd eq "EHLO" ? "ESMTP" : "SMTP";
    return ([250, $self->{domain}.' '.$self->ehlo_greet,
	     ($cmd eq "EHLO" ? $self->ehlo_lines : () )
	    ]);
}


sub ehlo_greet {
    my ($self) = @_;
    return ("greets ".$self->{state}->{Greeting});
}


sub ehlo_lines {
    my ($self) = @_;
    my @ehlo;
    push @ehlo, @{$self->{ehlo_lines}}
	if defined($self->{ehlo_lines});
    push @ehlo, map { $self->$_ } $self->{handlers}->ehlo_methods;
    return (@ehlo);
}


sub mail_handler {
    my ($self, $cmd, $path, $parm) = @_;
    my $state = $self->{state};
    # Section 4.1.4 puts certain requirements on the order of commands.
    return ([503, "You must say hello first"])
	if $state->state == 0;
    return ([503, "Transaction already started; issue RSET to start over"])
	if $state->state > 1;
    my $from = ReversePath($path);
    my $result = $self->mail_from($from, Parameters($parm));
    $state->{sender} = $from->reverse_path
	if $result->[0] == 250;
    return ($result);
}


sub mail_from {
    my ($self, $from, $parm) = @_;
    return ([501, "Syntax error: invalid parameters"])
	if $parm->count;
    return ([250, "OK"]);
}


sub rcpt_handler {
    my ($self, $cmd, $path, $parm) = @_;
    my $state = $self->{state};
    return ([503, "MAIL FROM: required first"])
	if $state->state < 2;
    my $to = ForwardPath($path);
    my $result = $self->rcpt_to($to, Parameters($parm));
    $self->rcpt_add($to)
	if $result->[0] =~ /^25./;
    return ($result);
}


sub rcpt_to {
    my ($self, $to, $parm) = @_;
    return ([501, "Syntax error: invalid parameters"])
	if $parm->count;
    return ([250, "Postmaster OK"])
	if not $to->is_path;
    return ($self->local_mailbox($to));
}


sub rcpt_add {
    my ($self, $rcpt) = @_;
    my $state = $self->{state};
    $state->{recipients} = []
	if not defined($state->{recipients});
    # new recipients pushed only if they don't appear in the list already
    my $path = $rcpt->forward_path;
    push @{$state->{recipients}}, $path
	if not map { $path eq $_ ? 1 : () } $state->recipients;
}


sub data_handler {
    my ($self) = @_;
    my $result;
    return ([503, "MAIL FROM: required first"])
	if $self->{state}->state < 2;
    return ([554, "No valid recipients"])
	if $self->{state}->state < 3;
    $result = $self->data_start;
    if ($result->[0] == 354) {
	$self->{mode} = 'data_mode';
    }
    else {
        $self->data_abort;
    }
    return ($result);
}


sub data_stamp {
    my ($self, $opts, $maxlen) = @_;
    $opts = $self->{stamp_opts} || ""
	if not defined($opts);
    $maxlen = 78
        if not defined($maxlen);
    my $state = $self->{state};
    my @parts =
	("Received: from ".encode_extended_domain($state->{Greeting}, $self->{peer_end}->address, $self->{peer_end}->name),
	 "by ".encode_extended_domain($self->{domain}, $self->{local_end}->address, $self->{local_end}->name),
	 ($opts !~ /v/ and -S $self->{in_fh} ? "via TCP" : ()),
	 ($opts !~ /w/ ? "with ".$state->{Protocol} : ()),
	 ($opts !~ /i/ and $state->{trans_id} ? "id ".$state->{trans_id} : ()),
	 ($opts !~ /f/ ? ("for", $state->recipients) : ()),
	 ";", gen_date_time(),
	 );
    # Wrap-parts-to-lines function follows.
    my @lines;
    my $continuer = "";
    while (@parts) {
	my $line = $continuer . shift(@parts);
	while (@parts) {
	    last if length($line) + length($parts[0]) >= $maxlen;
	    $line .= " ".shift(@parts);
	}
	push @lines, $line;
	$continuer = "\t";
    }
    return (@lines);
}


sub data_start {
    my ($self) = @_;
    $self->{state}->{data_lines} = 0;
    return ([354, "Start mail input; end with <CRLF>.<CRLF>"]);
}


sub data_line {}


sub data_finish { [250, "OK"] }


sub data_commit {}


sub data_abort {}


sub rset_handler {
    $_[0]->reset;
    return ([250, "OK"]);
}


sub quit_handler { [221, "Service closing transmission channel"] }


sub vrfy_handler {
    my ($self, $cmd, $string) = @_;
    $string = decode_string($string);
    return ([250, "postmaster"])
	if $string =~ /\Apostmaster\Z/i;
    return ([553, "Not a valid mailbox name"])
	if $string !~ /\A@{[MAILBOX_RE]}\z/o;
    return ($self->vrfy_mailbox(Mailbox($string)));
}


sub vrfy_mailbox {
    my ($self, $mailbox) = @_;
    my $result = $self->local_mailbox($mailbox);
    $result->[0] = 252
	if $result->[0] =~ /^4/;
    return ($result);
}


sub no_handler { [502, "Command not implemented"] }


sub bad_seq_handler { [503, "Bad sequence of commands"] }


sub local_mailbox { [250, "OK"] }


sub select_reply {
    my ($self, @argv) = @_;
    while (defined($argv[1])) {
	@argv[0,1] = @argv[1,0]
	    if $argv[0][0] > $argv[1][0];
	shift @argv;
    }
    return ($argv[0]);
}


sub reply {
    my ($self, $reply) = @_;
    my ($code, @blurb) = @$reply;
    # Convert to 421 if reply does not pass syntax checks.
    eval {
	die "attempted to send inappropriate reply code '$code'"
	    if $code !~ /\A[1-5][0-5]\d\Z/;
	die "attempted to send code $code with no accompanying text"
	    if not @blurb;
	for (@blurb) {
	    die "attempted to send illegal character in reply text"
		if tr/\012\015\200-\377//;
	}
    };
    if ($@) {
	$self->logmsg(c => "reply() failed: $@");
	$self->logmsg(i => "performing server-initiated quit (Bug!)");
	$code = 421;
	@blurb = ("Internal server error: closing connection");
    }
    # Insert domain in front of text for x2x codes.
    if ($code =~ /^.2./) {
	$blurb[0] = $self->{domain}." ".$blurb[0];
    }
    # Send the reply.
    my $last = pop @blurb;
    $self->reply_lines(map("$code-$_", @blurb), "$code $last");
    return ($code);
}


sub reply_lines {
    my $self = shift;
    $self->put(join($self->{eol}, @_).$self->{eol});
}


sub reset { $_[0]->{state}->reset }


sub peer_address_literal {
    my ($self, $alt) = @_;
    my $peer_ip = $self->{peer_end}->address;
    return ($peer_ip ? "[$peer_ip]" : $alt);
}


sub get_line {
    my ($self) = @_;
    local $/ = $self->{eol};
    my $line = $self->{in_fh}->getline();
    chomp($line)
	if defined($line);
    return ($line);
}


sub put {
    my ($self, $data) = @_;
    $self->{out_fh}->syswrite($data);
}


sub logmsg {}


sub hansard {}


sub cleanup {}



package RFCMail::ESMTP::Server::parser;

use strict;
use RFCMail::ESMTP::Grammar::Base qw(:server);


sub new {
    my $class = shift;
    return (bless {@_}, $class);
}


sub new_standard {
    my $class = shift;
    $class->new(
		'_'    => [undef,             'connect_handler'],
		'EHLO' => [DOMAIN_ARG_RE,     'ehlo_handler'],
		'HELO' => [DOMAIN_ARG_RE,     'ehlo_handler'],
		'MAIL' => [MAIL_ARGS_RE,      'mail_handler'],
		'RCPT' => [RCPT_ARGS_RE,      'rcpt_handler'],
		'DATA' => [undef,             'data_handler'],
		'RSET' => [undef,             'rset_handler'],
		'NOOP' => [OPT_STRING_ARG_RE, sub { [250, "OK"] }],
		'QUIT' => [undef,             'quit_handler'],
		'VRFY' => [STRING_ARG_RE,     'vrfy_handler', sub { 'VRFY' }],
		'HELP' => [OPT_STRING_ARG_RE, 'no_handler'],
		'EXPN' => [STRING_ARG_RE,     'no_handler'],
	       );
}


# Handlers for a refused session (see section 3.1)
sub new_refuser {
    my ($class, @welcome) = @_;
    @welcome = ("No SMTP service here")
	if not @welcome;
    $class->new(
		'_'    => [undef,             sub { [554, @welcome] }],
		'EHLO' => [DOMAIN_ARG_RE,     'bad_seq_handler'],
		'HELO' => [DOMAIN_ARG_RE,     'bad_seq_handler'],
		'MAIL' => [MAIL_ARGS_RE,      'bad_seq_handler'],
		'RCPT' => [RCPT_ARGS_RE,      'bad_seq_handler'],
		'DATA' => [undef,             'bad_seq_handler'],
		'RSET' => [undef,             'bad_seq_handler'],
		'NOOP' => [OPT_STRING_ARG_RE, 'bad_seq_handler'],
		'QUIT' => [undef,             'quit_handler'],
		'VRFY' => [STRING_ARG_RE,     'bad_seq_handler'],
		'HELP' => [OPT_STRING_ARG_RE, 'no_handler'],
		'EXPN' => [STRING_ARG_RE,     'no_handler'],
	       );
}


sub set {
    my ($self, $cmd, @data) = @_;
    if (@data) { $self->{$cmd} = [@data] }
    else { delete($self->{$cmd}) }
    return ($self);
}


sub ehlo_methods {
    my ($self) = @_;
    my @methods;
    for (values %$self) {
	push @methods, $_->[2]
	    if $_->[2];
    }
    return (@methods);
}


sub parse_line {
    my ($self, $line) = @_;
    my ($cmd, $args) = $line =~ /@{[COMMAND_RE]}/o;
    return (sub { [500, "Syntax error"] })
	if not defined($cmd);
    $cmd = uc($cmd);
    return ($self->parse_cmd($cmd, $args));
}


sub parse_cmd {
    my ($self, $cmd, $args) = @_;
    return (sub { [500, "Syntax error: command unrecognised"] })
	if not defined($self->{$cmd});
    my ($re, $method) = @{$self->{$cmd}};
    if (defined($re)) {
	$args = ""
	    if not defined($args);
	my @result = $args =~ /$re/;
	return ($method, $cmd, @result)
	    if @result;
    }
    return ($method, $cmd)
	if not defined($args);
    return (sub { [501, "Syntax error: arguments not valid for $cmd"] });
}



package RFCMail::ESMTP::Server::state;

use strict;


sub new {
    my $class = shift;
    return (bless {@_}, $class);
}


sub reset {
    my ($self) = @_;
    delete @{$self}{grep(/^[a-z]/, keys %{$self})};
    return ($self);
}


sub recipients {
    my ($self) = @_;
    return ()
	if not defined($self->{recipients});
    return (@{$self->{recipients}});
}


sub state {
    my ($self) = @_;
    return (0) # <= greeting not yet received
	if not defined($self->{Greeting});
    return (1) # <= no mail transaction in progress; awaiting "MAIL FROM:"
	if not defined($self->{sender});
    return (2) # <= "MAIL FROM:" received, but no valid recipients yet
	if not $self->recipients;
    return (3);# <= valid recipients exist; "DATA" acceptable
}


1;
